home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 1 / Gold Medal Software Volume 1 (Gold Medal) (1994).iso / prog / tpwprog7.arj / PBITMAP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-07-02  |  3.5 KB  |  147 lines
  1. { pbitmap.pas -- Print bitmaps }
  2.  
  3. program PBitmap;
  4.  
  5. {$R pbitmap.res}
  6.  
  7. uses WinTypes, WinProcs, WObjects, UPrint, UBitmap;
  8.  
  9. const
  10.  
  11.   fileName = 'c:\tpw\owldemos\racecar.bmp';
  12.  
  13.   id_Menu = 100;    { Menu resource ID }
  14.   cm_Print = 101;   { Menu:Print command ID }
  15.   cm_Quit = 102;    { Menu:Exit command ID }
  16.  
  17. type
  18.  
  19.   PBitmapApplication = object(TApplication)
  20.     procedure InitMainWindow; virtual;
  21.   end;
  22.  
  23.   PPBitmapWindow = ^PBitmapWindow;
  24.   PBitmapWindow = object(TWindow)
  25.     Bitmap: HBitmap;   { Handle to bitmap in memory }
  26.     Width, Height: LongInt; { Size of bitmap image }
  27.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  28.     destructor Done; virtual;
  29.     procedure SetupWindow; virtual;
  30.     procedure Paint(PaintDC: HDC;
  31.       var PaintInfo: TPaintStruct); virtual;
  32.     procedure CMPrint(var Msg: TMessage);
  33.       virtual cm_First + cm_Print;
  34.     procedure CMQuit(var Msg: TMessage);
  35.       virtual cm_First + cm_Quit;
  36.   end;
  37.  
  38.  
  39. { PBitmapApplication }
  40.  
  41. {- Initialize PBitmapApplication object's window }
  42. procedure PBitmapApplication.InitMainWindow;
  43. begin
  44.   MainWindow := New(PPBitmapWindow, Init(nil, 'PBitmap'))
  45. end;
  46.  
  47.  
  48. { PBitmapWindow }
  49.  
  50. {- Construct PBitmapWindow object }
  51. constructor PBitmapWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  52. begin
  53.   TWindow.Init(AParent, ATitle);
  54.   with Attr do
  55.   begin
  56.     X := 10; Y := 10; W := 500; H := 300;
  57.     Menu := LoadMenu(HInstance, PChar(id_Menu))
  58.   end
  59. end;
  60.  
  61. {- Destroy PBitmapWindow }
  62. destructor PBitmapWindow.Done;
  63. begin
  64.   if Bitmap <> 0 then DeleteObject(Bitmap);
  65.   TWindow.Done
  66. end;
  67.  
  68. {- Load and display bitmap }
  69. procedure PBitmapWindow.SetupWindow;
  70. begin
  71.   TWindow.SetupWindow;
  72.   Bitmap := LoadBitmap(fileName, HWindow, Width, Height);
  73.   if Bitmap = 0 then
  74.   begin
  75.     MessageBox(HWindow, 'File not found', 'Error',
  76.       mb_IconExclamation or mb_ok);
  77.     Halt
  78.   end
  79. end;
  80.  
  81. {- Paint bitmap inside window }
  82. procedure PBitmapWindow.Paint(PaintDC: HDC;
  83.   var PaintInfo: TPaintStruct);
  84. var
  85.   MemDC: HDC;
  86.   OldBitmap: HBitmap;
  87. begin
  88.   TWindow.Paint(PaintDC, PaintInfo);
  89.   if Bitmap <> 0 then
  90.   begin
  91.     MemDC := CreateCompatibleDC(PaintDC);
  92.     OldBitmap := SelectObject(MemDC, Bitmap);
  93.     BitBlt(PaintDC, 0, 0, Width, Height, MemDC, 0, 0, SRCCopy);
  94.     SelectObject(MemDC, OldBitmap);
  95.     DeleteDC(MemDC)
  96.   end
  97. end;
  98.  
  99. {- Execute Menu:Print command }
  100. procedure PBitmapWindow.CMPrint(var Msg: TMessage);
  101. var
  102.   N: Integer;
  103.   DC, MemDC: HDC;
  104.   OldBitmap: HBitmap;
  105. begin
  106.   if (Bitmap <> 0) and PrnStart('PBitmap') then
  107.   begin
  108.     N := GetDeviceCaps(PDc, RasterCaps);
  109.     if (N and rc_BitBlt) <> rc_BitBlt then
  110.       MessageBox(HWindow, 'Device does not support bitmaps',
  111.         'Error', mb_IconExclamation or mb_Ok)
  112.     else begin
  113.       DC := GetDC(HWindow);
  114.       MemDC := CreateCompatibleDC(DC);
  115.       ReleaseDC(HWindow, DC);
  116.       OldBitmap := SelectObject(MemDC, Bitmap);
  117.       BitBlt(PDc, 0, 0, Width, Height, MemDC, 0, 0, SRCCopy);
  118.       NewPage;
  119.       SelectObject(MemDC, OldBitmap);
  120.       DeleteDC(MemDC)
  121.     end;
  122.     PrnStop
  123.   end
  124. end;
  125.  
  126. {- Execute Menu:Exit command }
  127. procedure PBitmapWindow.CMQuit(var Msg: TMessage);
  128. begin
  129.   CloseWindow
  130. end;
  131.  
  132. var
  133.  
  134.   PBitmapApp: PBitmapApplication;
  135.  
  136. begin
  137.   PBitmapApp.Init('PBitmapApp');
  138.   PBitmapApp.Run;
  139.   PBitmapApp.Done
  140. end.
  141.  
  142.  
  143. {--------------------------------------------------------------
  144.   Copyright (c) 1991 by Tom Swan. All rights reserved.
  145.   Revision 1.00    Date: 5/17/1991
  146. ---------------------------------------------------------------}
  147.